home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclTestObj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  31.6 KB  |  1,098 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclTestObj.c --
  3.  *
  4.  *    This file contains C command procedures for the additional Tcl
  5.  *    commands that are used for testing implementations of the Tcl object
  6.  *    types. These commands are not normally included in Tcl
  7.  *    applications; they're only used for testing.
  8.  *
  9.  * Copyright (c) 1995, 1996 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * SCCS: @(#) tclTestObj.c 1.27 97/05/19 17:37:31
  15.  */
  16.  
  17. #include "tclInt.h"
  18.  
  19. /*
  20.  * An array of Tcl_Obj pointers used in the commands that operate on or get
  21.  * the values of Tcl object-valued variables. varPtr[i] is the i-th
  22.  * variable's Tcl_Obj *.
  23.  */
  24.  
  25. #define NUMBER_OF_OBJECT_VARS 20
  26. static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
  27.  
  28. /*
  29.  * Forward declarations for procedures defined later in this file:
  30.  */
  31.  
  32. static int        CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
  33.                 int varIndex));
  34. static int        GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
  35.                 char *string, int *indexPtr));
  36. static void        SetVarToObj _ANSI_ARGS_((int varIndex,
  37.                 Tcl_Obj *objPtr));
  38. int            TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
  39. static int        TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
  40.                 Tcl_Interp *interp, int objc,
  41.                 Tcl_Obj *CONST objv[]));
  42. static int        TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
  43.                 Tcl_Interp *interp, int objc,
  44.                 Tcl_Obj *CONST objv[]));
  45. static int        TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
  46.                 Tcl_Interp *interp, int objc,
  47.                 Tcl_Obj *CONST objv[]));
  48. static int        TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
  49.                 Tcl_Interp *interp, int objc,
  50.                 Tcl_Obj *CONST objv[]));
  51. static int        TestintobjCmd _ANSI_ARGS_((ClientData dummy,
  52.                 Tcl_Interp *interp, int objc,
  53.                 Tcl_Obj *CONST objv[]));
  54. static int        TestobjCmd _ANSI_ARGS_((ClientData dummy,
  55.                 Tcl_Interp *interp, int objc,
  56.                 Tcl_Obj *CONST objv[]));
  57. static int        TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
  58.                 Tcl_Interp *interp, int objc,
  59.                 Tcl_Obj *CONST objv[]));
  60.  
  61. /*
  62.  *----------------------------------------------------------------------
  63.  *
  64.  * TclObjTest_Init --
  65.  *
  66.  *    This procedure creates additional commands that are used to test the
  67.  *    Tcl object support.
  68.  *
  69.  * Results:
  70.  *    Returns a standard Tcl completion code, and leaves an error
  71.  *    message in interp->result if an error occurs.
  72.  *
  73.  * Side effects:
  74.  *    Creates and registers several new testing commands.
  75.  *
  76.  *----------------------------------------------------------------------
  77.  */
  78.  
  79. int
  80. TclObjTest_Init(interp)
  81.     Tcl_Interp *interp;
  82. {
  83.     register int i;
  84.     
  85.     for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
  86.         varPtr[i] = NULL;
  87.     }
  88.     
  89.     Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
  90.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  91.     Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
  92.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  93.     Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
  94.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  95.     Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
  96.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  97.     Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
  98.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  99.     Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
  100.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  101.     Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
  102.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  103.     return TCL_OK;
  104. }
  105.  
  106. /*
  107.  *----------------------------------------------------------------------
  108.  *
  109.  * TestbooleanobjCmd --
  110.  *
  111.  *    This procedure implements the "testbooleanobj" command.  It is used
  112.  *    to test the boolean Tcl object type implementation.
  113.  *
  114.  * Results:
  115.  *    A standard Tcl object result.
  116.  *
  117.  * Side effects:
  118.  *    Creates and frees boolean objects, and also converts objects to
  119.  *    have boolean type.
  120.  *
  121.  *----------------------------------------------------------------------
  122.  */
  123.  
  124. static int
  125. TestbooleanobjCmd(clientData, interp, objc, objv)
  126.     ClientData clientData;    /* Not used. */
  127.     Tcl_Interp *interp;        /* Current interpreter. */
  128.     int objc;            /* Number of arguments. */
  129.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  130. {
  131.     int varIndex, boolValue, length;
  132.     char *index, *subCmd;
  133.  
  134.     if (objc < 3) {
  135.     wrongNumArgs:
  136.     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  137.     return TCL_ERROR;
  138.     }
  139.  
  140.     /*
  141.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  142.      */
  143.  
  144.     index = Tcl_GetStringFromObj(objv[2], &length);
  145.     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  146.     return TCL_ERROR;
  147.     }
  148.  
  149.     subCmd = Tcl_GetStringFromObj(objv[1], &length);
  150.     if (strcmp(subCmd, "set") == 0) {
  151.     if (objc != 4) {
  152.         goto wrongNumArgs;
  153.     }
  154.     if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
  155.         return TCL_ERROR;
  156.     }
  157.  
  158.     /*
  159.      * If the object currently bound to the variable with index varIndex
  160.      * has ref count 1 (i.e. the object is unshared) we can modify that
  161.      * object directly. Otherwise, if RC>1 (i.e. the object is shared),
  162.      * we must create a new object to modify/set and decrement the old
  163.      * formerly-shared object's ref count. This is "copy on write".
  164.      */
  165.  
  166.     if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  167.         Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
  168.     } else {
  169.         SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
  170.     }
  171.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  172.     } else if (strcmp(subCmd, "get") == 0) {
  173.     if (objc != 3) {
  174.         goto wrongNumArgs;
  175.     }
  176.     if (CheckIfVarUnset(interp, varIndex)) {
  177.         return TCL_ERROR;
  178.     }
  179.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  180.     } else if (strcmp(subCmd, "not") == 0) {
  181.     if (objc != 3) {
  182.         goto wrongNumArgs;
  183.     }
  184.     if (CheckIfVarUnset(interp, varIndex)) {
  185.         return TCL_ERROR;
  186.     }
  187.     if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
  188.                   &boolValue) != TCL_OK) {
  189.         return TCL_ERROR;
  190.     }
  191.     if (!Tcl_IsShared(varPtr[varIndex])) {
  192.         Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
  193.     } else {
  194.         SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
  195.     }
  196.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  197.     } else {
  198.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  199.         "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
  200.         "\": must be set, get, or not", (char *) NULL);
  201.     return TCL_ERROR;
  202.     }
  203.     return TCL_OK;
  204. }
  205.  
  206. /*
  207.  *----------------------------------------------------------------------
  208.  *
  209.  * TestconvertobjCmd --
  210.  *
  211.  *    This procedure implements the "testconvertobj" command. It is used
  212.  *    to test converting objects to new types.
  213.  *
  214.  * Results:
  215.  *    A standard Tcl object result.
  216.  *
  217.  * Side effects:
  218.  *    Converts objects to new types.
  219.  *
  220.  *----------------------------------------------------------------------
  221.  */
  222.  
  223. static int
  224. TestconvertobjCmd(clientData, interp, objc, objv)
  225.     ClientData clientData;    /* Not used. */
  226.     Tcl_Interp *interp;        /* Current interpreter. */
  227.     int objc;            /* Number of arguments. */
  228.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  229. {
  230.     int length;
  231.     char *subCmd;
  232.     char buf[20];
  233.  
  234.     if (objc < 3) {
  235.     wrongNumArgs:
  236.     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  237.     return TCL_ERROR;
  238.     }
  239.  
  240.     /*
  241.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  242.      */
  243.  
  244.     subCmd = Tcl_GetStringFromObj(objv[1], &length);
  245.     if (strcmp(subCmd, "double") == 0) {
  246.     double d;
  247.  
  248.     if (objc != 3) {
  249.         goto wrongNumArgs;
  250.     }
  251.     if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
  252.         return TCL_ERROR;
  253.     }
  254.     sprintf(buf, "%f", d);
  255.         Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  256.     } else {
  257.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  258.         "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
  259.         "\": must be double", (char *) NULL);
  260.     return TCL_ERROR;
  261.     }
  262.     return TCL_OK;
  263. }
  264.  
  265. /*
  266.  *----------------------------------------------------------------------
  267.  *
  268.  * TestdoubleobjCmd --
  269.  *
  270.  *    This procedure implements the "testdoubleobj" command.  It is used
  271.  *    to test the double-precision floating point Tcl object type
  272.  *    implementation.
  273.  *
  274.  * Results:
  275.  *    A standard Tcl object result.
  276.  *
  277.  * Side effects:
  278.  *    Creates and frees double objects, and also converts objects to
  279.  *    have double type.
  280.  *
  281.  *----------------------------------------------------------------------
  282.  */
  283.  
  284. static int
  285. TestdoubleobjCmd(clientData, interp, objc, objv)
  286.     ClientData clientData;    /* Not used. */
  287.     Tcl_Interp *interp;        /* Current interpreter. */
  288.     int objc;            /* Number of arguments. */
  289.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  290. {
  291.     int varIndex, length;
  292.     double doubleValue;
  293.     char *index, *subCmd, *string;
  294.     
  295.     if (objc < 3) {
  296.     wrongNumArgs:
  297.     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  298.     return TCL_ERROR;
  299.     }
  300.  
  301.     /*
  302.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  303.      */
  304.  
  305.     index = Tcl_GetStringFromObj(objv[2], &length);
  306.     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  307.     return TCL_ERROR;
  308.     }
  309.  
  310.     subCmd = Tcl_GetStringFromObj(objv[1], &length);
  311.     if (strcmp(subCmd, "set") == 0) {
  312.     if (objc != 4) {
  313.         goto wrongNumArgs;
  314.     }
  315.     string = Tcl_GetStringFromObj(objv[3], &length);
  316.     if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
  317.         return TCL_ERROR;
  318.     }
  319.  
  320.     /*
  321.      * If the object currently bound to the variable with index varIndex
  322.      * has ref count 1 (i.e. the object is unshared) we can modify that
  323.      * object directly. Otherwise, if RC>1 (i.e. the object is shared),
  324.      * we must create a new object to modify/set and decrement the old
  325.      * formerly-shared object's ref count. This is "copy on write".
  326.      */
  327.  
  328.     if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  329.         Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
  330.     } else {
  331.         SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
  332.     }
  333.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  334.     } else if (strcmp(subCmd, "get") == 0) {
  335.     if (objc != 3) {
  336.         goto wrongNumArgs;
  337.     }
  338.     if (CheckIfVarUnset(interp, varIndex)) {
  339.         return TCL_ERROR;
  340.     }
  341.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  342.     } else if (strcmp(subCmd, "mult10") == 0) {
  343.     if (objc != 3) {
  344.         goto wrongNumArgs;
  345.     }
  346.     if (CheckIfVarUnset(interp, varIndex)) {
  347.         return TCL_ERROR;
  348.     }
  349.     if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
  350.                  &doubleValue) != TCL_OK) {
  351.         return TCL_ERROR;
  352.     }
  353.     if (!Tcl_IsShared(varPtr[varIndex])) {
  354.         Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
  355.     } else {
  356.         SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
  357.     }
  358.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  359.     } else if (strcmp(subCmd, "div10") == 0) {
  360.     if (objc != 3) {
  361.         goto wrongNumArgs;
  362.     }
  363.     if (CheckIfVarUnset(interp, varIndex)) {
  364.         return TCL_ERROR;
  365.     }
  366.     if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
  367.                  &doubleValue) != TCL_OK) {
  368.         return TCL_ERROR;
  369.     }
  370.     if (!Tcl_IsShared(varPtr[varIndex])) {
  371.         Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
  372.     } else {
  373.         SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
  374.     }
  375.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  376.     } else {
  377.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  378.         "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
  379.         "\": must be set, get, mult10, or div10", (char *) NULL);
  380.     return TCL_ERROR;
  381.     }
  382.     return TCL_OK;
  383. }
  384.  
  385. /*
  386.  *----------------------------------------------------------------------
  387.  *
  388.  * TestindexobjCmd --
  389.  *
  390.  *    This procedure implements the "testindexobj" command. It is used to
  391.  *    test the index Tcl object type implementation.
  392.  *
  393.  * Results:
  394.  *    A standard Tcl object result.
  395.  *
  396.  * Side effects:
  397.  *    Creates and frees int objects, and also converts objects to
  398.  *    have int type.
  399.  *
  400.  *----------------------------------------------------------------------
  401.  */
  402.  
  403. static int
  404. TestindexobjCmd(clientData, interp, objc, objv)
  405.     ClientData clientData;    /* Not used. */
  406.     Tcl_Interp *interp;        /* Current interpreter. */
  407.     int objc;            /* Number of arguments. */
  408.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  409. {
  410.     int allowAbbrev, index, index2, setError, i, dummy, result;
  411.     char **argv;
  412.     static char *tablePtr[] = {"a", "b", "check", (char *) NULL};
  413.  
  414.     if ((objc == 3) && (strcmp(Tcl_GetStringFromObj(objv[1], &dummy),
  415.         "check") == 0)) {
  416.     /*
  417.      * This code checks to be sure that the results of
  418.      * Tcl_GetIndexFromObj are properly cached in the object and
  419.      * returned on subsequent lookups.
  420.      */
  421.  
  422.     Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
  423.         "token", 0, &index);
  424.     if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
  425.         return TCL_ERROR;
  426.     }
  427.     objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2;
  428.     result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
  429.         tablePtr, "token", 0, &index);
  430.     if (result == TCL_OK) {
  431.         Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
  432.     }
  433.     return result;
  434.     }
  435.  
  436.     if (objc < 5) {
  437.     Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
  438.     return TCL_ERROR;
  439.     }
  440.  
  441.     if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
  442.     return TCL_ERROR;
  443.     }
  444.     if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
  445.     return TCL_ERROR;
  446.     }
  447.     argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
  448.     for (i = 4; i < objc; i++) {
  449.     argv[i-4] = Tcl_GetStringFromObj(objv[i], &dummy);
  450.     }
  451.     argv[objc-4] = NULL;
  452.     result = Tcl_GetIndexFromObj(setError ? interp : NULL, objv[3],
  453.         argv, "token", allowAbbrev ? 0 : TCL_EXACT, &index);
  454.     ckfree((char *) argv);
  455.     if (result == TCL_OK) {
  456.     Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
  457.     }
  458.     return result;
  459. }
  460.  
  461. /*
  462.  *----------------------------------------------------------------------
  463.  *
  464.  * TestintobjCmd --
  465.  *
  466.  *    This procedure implements the "testintobj" command. It is used to
  467.  *    test the int Tcl object type implementation.
  468.  *
  469.  * Results:
  470.  *    A standard Tcl object result.
  471.  *
  472.  * Side effects:
  473.  *    Creates and frees int objects, and also converts objects to
  474.  *    have int type.
  475.  *
  476.  *----------------------------------------------------------------------
  477.  */
  478.  
  479. static int
  480. TestintobjCmd(clientData, interp, objc, objv)
  481.     ClientData clientData;    /* Not used. */
  482.     Tcl_Interp *interp;        /* Current interpreter. */
  483.     int objc;            /* Number of arguments. */
  484.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  485. {
  486.     int intValue, varIndex, length, i;
  487.     long longValue;
  488.     char *index, *subCmd, *string;
  489.     
  490.     if (objc < 3) {
  491.     wrongNumArgs:
  492.     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  493.     return TCL_ERROR;
  494.     }
  495.  
  496.     /*
  497.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  498.      */
  499.  
  500.     index = Tcl_GetStringFromObj(objv[2], &length);
  501.     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  502.     return TCL_ERROR;
  503.     }
  504.  
  505.     subCmd = Tcl_GetStringFromObj(objv[1], &length);
  506.     if (strcmp(subCmd, "set") == 0) {
  507.     if (objc != 4) {
  508.         goto wrongNumArgs;
  509.     }
  510.     string = Tcl_GetStringFromObj(objv[3], &length);
  511.     if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
  512.         return TCL_ERROR;
  513.     }
  514.     intValue = i;
  515.  
  516.     /*
  517.      * If the object currently bound to the variable with index varIndex
  518.      * has ref count 1 (i.e. the object is unshared) we can modify that
  519.      * object directly. Otherwise, if RC>1 (i.e. the object is shared),
  520.      * we must create a new object to modify/set and decrement the old
  521.      * formerly-shared object's ref count. This is "copy on write".
  522.      */
  523.  
  524.     if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  525.         Tcl_SetIntObj(varPtr[varIndex], intValue);
  526.     } else {
  527.         SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
  528.     }
  529.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  530.     } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
  531.     if (objc != 4) {
  532.         goto wrongNumArgs;
  533.     }
  534.     string = Tcl_GetStringFromObj(objv[3], &length);
  535.     if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
  536.         return TCL_ERROR;
  537.     }
  538.     intValue = i;
  539.     if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  540.         Tcl_SetIntObj(varPtr[varIndex], intValue);
  541.     } else {
  542.         SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
  543.     }
  544.     } else if (strcmp(subCmd, "setlong") == 0) {
  545.     if (objc != 4) {
  546.         goto wrongNumArgs;
  547.     }
  548.     string = Tcl_GetStringFromObj(objv[3], &length);
  549.     if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
  550.         return TCL_ERROR;
  551.     }
  552.     intValue = i;
  553.     if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  554.         Tcl_SetLongObj(varPtr[varIndex], intValue);
  555.     } else {
  556.         SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
  557.     }
  558.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  559.     } else if (strcmp(subCmd, "setmaxlong") == 0) {
  560.     long maxLong = LONG_MAX;
  561.     if (objc != 3) {
  562.         goto wrongNumArgs;
  563.     }
  564.     if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  565.         Tcl_SetLongObj(varPtr[varIndex], maxLong);
  566.     } else {
  567.         SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
  568.     }
  569.     } else if (strcmp(subCmd, "ismaxlong") == 0) {
  570.     if (objc != 3) {
  571.         goto wrongNumArgs;
  572.     }
  573.     if (CheckIfVarUnset(interp, varIndex)) {
  574.         return TCL_ERROR;
  575.     }
  576.     if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
  577.         return TCL_ERROR;
  578.     }
  579.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  580.             ((longValue == LONG_MAX)? "1" : "0"), -1);
  581.     } else if (strcmp(subCmd, "get") == 0) {
  582.     if (objc != 3) {
  583.         goto wrongNumArgs;
  584.     }
  585.     if (CheckIfVarUnset(interp, varIndex)) {
  586.         return TCL_ERROR;
  587.     }
  588.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  589.     } else if (strcmp(subCmd, "inttoobigtest") == 0) {
  590.     /*
  591.      * If long ints have more bits than ints on this platform, verify
  592.      * that Tcl_GetIntFromObj returns an error if the long int held
  593.      * in an integer object's internal representation is too large
  594.      * to fit in an int.
  595.      */
  596.     
  597.     long maxLong = LONG_MAX;
  598.     
  599.     if (objc != 3) {
  600.         goto wrongNumArgs;
  601.     }
  602.     if (INT_MAX == LONG_MAX) { /* int is same size as long int */
  603.         Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
  604.     } else {
  605.         if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
  606.         Tcl_SetLongObj(varPtr[varIndex], maxLong);
  607.         } else {
  608.         SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
  609.         }
  610.         if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
  611.         Tcl_ResetResult(interp);
  612.         Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
  613.         return TCL_OK;
  614.         }
  615.         Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
  616.     }
  617.     } else if (strcmp(subCmd, "mult10") == 0) {
  618.     if (objc != 3) {
  619.         goto wrongNumArgs;
  620.     }
  621.     if (CheckIfVarUnset(interp, varIndex)) {
  622.         return TCL_ERROR;
  623.     }
  624.     if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
  625.                   &intValue) != TCL_OK) {
  626.         return TCL_ERROR;
  627.     }
  628.     if (!Tcl_IsShared(varPtr[varIndex])) {
  629.         Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
  630.     } else {
  631.         SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
  632.     }
  633.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  634.     } else if (strcmp(subCmd, "div10") == 0) {
  635.     if (objc != 3) {
  636.         goto wrongNumArgs;
  637.     }
  638.     if (CheckIfVarUnset(interp, varIndex)) {
  639.         return TCL_ERROR;
  640.     }
  641.     if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
  642.                   &intValue) != TCL_OK) {
  643.         return TCL_ERROR;
  644.     }
  645.     if (!Tcl_IsShared(varPtr[varIndex])) {
  646.         Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
  647.     } else {
  648.         SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
  649.     }
  650.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  651.     } else {
  652.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  653.         "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
  654.         "\": must be set, get, mult10, or div10", (char *) NULL);
  655.     return TCL_ERROR;
  656.     }
  657.     return TCL_OK;
  658. }
  659.  
  660. /*
  661.  *----------------------------------------------------------------------
  662.  *
  663.  * TestobjCmd --
  664.  *
  665.  *    This procedure implements the "testobj" command. It is used to test
  666.  *    the type-independent portions of the Tcl object type implementation.
  667.  *
  668.  * Results:
  669.  *    A standard Tcl object result.
  670.  *
  671.  * Side effects:
  672.  *    Creates and frees objects.
  673.  *
  674.  *----------------------------------------------------------------------
  675.  */
  676.  
  677. static int
  678. TestobjCmd(clientData, interp, objc, objv)
  679.     ClientData clientData;    /* Not used. */
  680.     Tcl_Interp *interp;        /* Current interpreter. */
  681.     int objc;            /* Number of arguments. */
  682.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  683. {
  684.     int varIndex, destIndex, i;
  685.     char *index, *subCmd, *string;
  686.     Tcl_ObjType *targetType;
  687.     char buf[20];
  688.     int length;
  689.     
  690.     if (objc < 2) {
  691.     wrongNumArgs:
  692.     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  693.     return TCL_ERROR;
  694.     }
  695.  
  696.     /*
  697.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  698.      */
  699.  
  700.     subCmd = Tcl_GetStringFromObj(objv[1], &length);
  701.     if (strcmp(subCmd, "assign") == 0) {
  702.         if (objc != 4) {
  703.             goto wrongNumArgs;
  704.         }
  705.         index = Tcl_GetStringFromObj(objv[2], &length);
  706.         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  707.             return TCL_ERROR;
  708.         }
  709.         if (CheckIfVarUnset(interp, varIndex)) {
  710.         return TCL_ERROR;
  711.     }
  712.     string = Tcl_GetStringFromObj(objv[3], &length);
  713.         if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
  714.             return TCL_ERROR;
  715.         }
  716.         SetVarToObj(destIndex, varPtr[varIndex]);
  717.     Tcl_SetObjResult(interp, varPtr[destIndex]);
  718.      } else if (strcmp(subCmd, "convert") == 0) {
  719.         char *typeName;
  720.         if (objc != 4) {
  721.             goto wrongNumArgs;
  722.         }
  723.         index = Tcl_GetStringFromObj(objv[2], &length);
  724.         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  725.             return TCL_ERROR;
  726.         }
  727.         if (CheckIfVarUnset(interp, varIndex)) {
  728.         return TCL_ERROR;
  729.     }
  730.         typeName = Tcl_GetStringFromObj(objv[3], &length);
  731.         if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
  732.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  733.             "no type ", typeName, " found", (char *) NULL);
  734.             return TCL_ERROR;
  735.         }
  736.         if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
  737.             != TCL_OK) {
  738.             return TCL_ERROR;
  739.         }
  740.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  741.     } else if (strcmp(subCmd, "duplicate") == 0) {
  742.         if (objc != 4) {
  743.             goto wrongNumArgs;
  744.         }
  745.         index = Tcl_GetStringFromObj(objv[2], &length);
  746.         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  747.             return TCL_ERROR;
  748.         }
  749.         if (CheckIfVarUnset(interp, varIndex)) {
  750.         return TCL_ERROR;
  751.     }
  752.     string = Tcl_GetStringFromObj(objv[3], &length);
  753.         if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
  754.             return TCL_ERROR;
  755.         }
  756.         SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
  757.     Tcl_SetObjResult(interp, varPtr[destIndex]);
  758.     } else if (strcmp(subCmd, "freeallvars") == 0) {
  759.         if (objc != 2) {
  760.             goto wrongNumArgs;
  761.         }
  762.         for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
  763.             if (varPtr[i] != NULL) {
  764.                 Tcl_DecrRefCount(varPtr[i]);
  765.                 varPtr[i] = NULL;
  766.             }
  767.         }
  768.     } else if (strcmp(subCmd, "newobj") == 0) {
  769.         if (objc != 3) {
  770.             goto wrongNumArgs;
  771.         }
  772.         index = Tcl_GetStringFromObj(objv[2], &length);
  773.         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  774.             return TCL_ERROR;
  775.         }
  776.         SetVarToObj(varIndex, Tcl_NewObj());
  777.     Tcl_SetObjResult(interp, varPtr[varIndex]);
  778.     } else if (strcmp(subCmd, "refcount") == 0) {
  779.         if (objc != 3) {
  780.             goto wrongNumArgs;
  781.         }
  782.         index = Tcl_GetStringFromObj(objv[2], &length);
  783.         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  784.             return TCL_ERROR;
  785.         }
  786.         if (CheckIfVarUnset(interp, varIndex)) {
  787.         return TCL_ERROR;
  788.     }
  789.         sprintf(buf, "%d", varPtr[varIndex]->refCount);
  790.         Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  791.     } else if (strcmp(subCmd, "type") == 0) {
  792.         if (objc != 3) {
  793.             goto wrongNumArgs;
  794.         }
  795.         index = Tcl_GetStringFromObj(objv[2], &length);
  796.         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  797.             return TCL_ERROR;
  798.         }
  799.         if (CheckIfVarUnset(interp, varIndex)) {
  800.         return TCL_ERROR;
  801.     }
  802.         if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
  803.         Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
  804.         } else {
  805.             Tcl_AppendToObj(Tcl_GetObjResult(interp),
  806.                     varPtr[varIndex]->typePtr->name, -1);
  807.         }
  808.     } else if (strcmp(subCmd, "types") == 0) {
  809.         if (objc != 2) {
  810.             goto wrongNumArgs;
  811.         }
  812.     if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) {
  813.         return TCL_ERROR;
  814.     }
  815.     } else {
  816.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  817.         "bad option \"",
  818.         Tcl_GetStringFromObj(objv[1], (int *) NULL),
  819.         "\": must be assign, convert, duplicate, freeallvars, ",
  820.         "newobj, objcount, refcount, type, or types",
  821.         (char *) NULL);
  822.     return TCL_ERROR;
  823.     }
  824.     return TCL_OK;
  825. }
  826.  
  827. /*
  828.  *----------------------------------------------------------------------
  829.  *
  830.  * TeststringobjCmd --
  831.  *
  832.  *    This procedure implements the "teststringobj" command. It is used to
  833.  *    test the string Tcl object type implementation.
  834.  *
  835.  * Results:
  836.  *    A standard Tcl object result.
  837.  *
  838.  * Side effects:
  839.  *    Creates and frees string objects, and also converts objects to
  840.  *    have string type.
  841.  *
  842.  *----------------------------------------------------------------------
  843.  */
  844.  
  845. static int
  846. TeststringobjCmd(clientData, interp, objc, objv)
  847.     ClientData clientData;    /* Not used. */
  848.     Tcl_Interp *interp;        /* Current interpreter. */
  849.     int objc;            /* Number of arguments. */
  850.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  851. {
  852.     int varIndex, option, i, length;
  853. #define MAX_STRINGS 10
  854.     char *index, *string, *strings[MAX_STRINGS+1];
  855.     static char *options[] = {
  856.     "append", "appendstrings", "get", "length", "length2",
  857.     "set", "set2", "setlength", (char *) NULL
  858.     };
  859.  
  860.     if (objc < 3) {
  861.     wrongNumArgs:
  862.     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  863.     return TCL_ERROR;
  864.     }
  865.  
  866.     index = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  867.     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
  868.     return TCL_ERROR;
  869.     }
  870.  
  871.     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
  872.         != TCL_OK) {
  873.     return TCL_ERROR;
  874.     }
  875.     switch (option) {
  876.     case 0:                /* append */
  877.         if (objc != 5) {
  878.         goto wrongNumArgs;
  879.         }
  880.         if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
  881.         return TCL_ERROR;
  882.         }
  883.         if (varPtr[varIndex] == NULL) {
  884.         SetVarToObj(varIndex, Tcl_NewObj());
  885.         }
  886.         
  887.         /*
  888.          * If the object bound to variable "varIndex" is shared, we must
  889.          * "copy on write" and append to a copy of the object. 
  890.          */
  891.         
  892.         if (Tcl_IsShared(varPtr[varIndex])) {
  893.         SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
  894.         }
  895.         string = Tcl_GetStringFromObj(objv[3], (int *) NULL);
  896.         Tcl_AppendToObj(varPtr[varIndex], string, length);
  897.         Tcl_SetObjResult(interp, varPtr[varIndex]);
  898.         break;
  899.     case 1:                /* appendstrings */
  900.         if (objc > (MAX_STRINGS+3)) {
  901.         goto wrongNumArgs;
  902.         }
  903.         if (varPtr[varIndex] == NULL) {
  904.         SetVarToObj(varIndex, Tcl_NewObj());
  905.         }
  906.  
  907.         /*
  908.          * If the object bound to variable "varIndex" is shared, we must
  909.          * "copy on write" and append to a copy of the object. 
  910.          */
  911.  
  912.         if (Tcl_IsShared(varPtr[varIndex])) {
  913.         SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
  914.         }
  915.         for (i = 3;  i < objc;  i++) {
  916.         strings[i-3] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
  917.         }
  918.         strings[objc-3] = NULL;
  919.         Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
  920.             strings[2], strings[3], strings[4], strings[5],
  921.             strings[6], strings[7], strings[8], strings[9],
  922.             strings[10], strings[11]);
  923.         Tcl_SetObjResult(interp, varPtr[varIndex]);
  924.         break;
  925.     case 2:                /* get */
  926.         if (objc != 3) {
  927.         goto wrongNumArgs;
  928.         }
  929.         if (CheckIfVarUnset(interp, varIndex)) {
  930.         return TCL_ERROR;
  931.         }
  932.         Tcl_SetObjResult(interp, varPtr[varIndex]);
  933.         break;
  934.     case 3:                /* length */
  935.         if (objc != 3) {
  936.         goto wrongNumArgs;
  937.         }
  938.         Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
  939.             ? varPtr[varIndex]->length : -1);
  940.         break;
  941.     case 4:                /* length2 */
  942.         if (objc != 3) {
  943.         goto wrongNumArgs;
  944.         }
  945.         Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
  946.             ? (int) varPtr[varIndex]->internalRep.longValue : -1);
  947.         break;
  948.     case 5:                /* set */
  949.         if (objc != 4) {
  950.         goto wrongNumArgs;
  951.         }
  952.  
  953.         /*
  954.          * If the object currently bound to the variable with index
  955.          * varIndex has ref count 1 (i.e. the object is unshared) we
  956.          * can modify that object directly. Otherwise, if RC>1 (i.e.
  957.          * the object is shared), we must create a new object to
  958.          * modify/set and decrement the old formerly-shared object's
  959.          * ref count. This is "copy on write".
  960.          */
  961.     
  962.         string = Tcl_GetStringFromObj(objv[3], &length);
  963.         if ((varPtr[varIndex] != NULL)
  964.             && !Tcl_IsShared(varPtr[varIndex])) {
  965.         Tcl_SetStringObj(varPtr[varIndex], string, length);
  966.         } else {
  967.         SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
  968.         }
  969.         Tcl_SetObjResult(interp, varPtr[varIndex]);
  970.         break;
  971.     case 6:                /* set2 */
  972.         if (objc != 4) {
  973.         goto wrongNumArgs;
  974.         }
  975.         SetVarToObj(varIndex, objv[3]);
  976.         break;
  977.     case 7:                /* setlength */
  978.         if (objc != 4) {
  979.         goto wrongNumArgs;
  980.         }
  981.         if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
  982.         return TCL_ERROR;
  983.         }
  984.         if (varPtr[varIndex] != NULL) {
  985.         Tcl_SetObjLength(varPtr[varIndex], length);
  986.         }
  987.         break;
  988.     }
  989.  
  990.     return TCL_OK;
  991. }
  992.  
  993. /*
  994.  *----------------------------------------------------------------------
  995.  *
  996.  * SetVarToObj --
  997.  *
  998.  *    Utility routine to assign a Tcl_Obj* to a test variable. The
  999.  *    Tcl_Obj* can be NULL.
  1000.  *
  1001.  * Results:
  1002.  *    None.
  1003.  *
  1004.  * Side effects:
  1005.  *    This routine handles ref counting details for assignment:
  1006.  *    i.e. the old value's ref count must be decremented (if not NULL) and
  1007.  *    the new one incremented (also if not NULL).
  1008.  *
  1009.  *----------------------------------------------------------------------
  1010.  */
  1011.  
  1012. static void
  1013. SetVarToObj(varIndex, objPtr)
  1014.     int varIndex;        /* Designates the assignment variable. */
  1015.     Tcl_Obj *objPtr;        /* Points to object to assign to var. */
  1016. {
  1017.     if (varPtr[varIndex] != NULL) {
  1018.     Tcl_DecrRefCount(varPtr[varIndex]);
  1019.     }
  1020.     varPtr[varIndex] = objPtr;
  1021.     if (objPtr != NULL) {
  1022.     Tcl_IncrRefCount(objPtr);
  1023.     }
  1024. }
  1025.  
  1026. /*
  1027.  *----------------------------------------------------------------------
  1028.  *
  1029.  * GetVariableIndex --
  1030.  *
  1031.  *    Utility routine to get a test variable index from the command line.
  1032.  *
  1033.  * Results:
  1034.  *    A standard Tcl object result.
  1035.  *
  1036.  * Side effects:
  1037.  *    None.
  1038.  *
  1039.  *----------------------------------------------------------------------
  1040.  */
  1041.  
  1042. static int
  1043. GetVariableIndex(interp, string, indexPtr)
  1044.     Tcl_Interp *interp;         /* Interpreter for error reporting. */
  1045.     char *string;               /* String containing a variable index
  1046.                  * specified as a nonnegative number less
  1047.                  * than NUMBER_OF_OBJECT_VARS. */
  1048.     int *indexPtr;              /* Place to store converted result. */
  1049. {
  1050.     int index;
  1051.     
  1052.     if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
  1053.     return TCL_ERROR;
  1054.     }
  1055.     if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
  1056.     Tcl_ResetResult(interp);
  1057.     Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
  1058.     return TCL_ERROR;
  1059.     }
  1060.  
  1061.     *indexPtr = index;
  1062.     return TCL_OK;
  1063. }
  1064.  
  1065. /*
  1066.  *----------------------------------------------------------------------
  1067.  *
  1068.  * CheckIfVarUnset --
  1069.  *
  1070.  *    Utility procedure that checks whether a test variable is readable:
  1071.  *    i.e., that varPtr[varIndex] is non-NULL.
  1072.  *
  1073.  * Results:
  1074.  *    1 if the test variable is unset (NULL); 0 otherwise.
  1075.  *
  1076.  * Side effects:
  1077.  *    Sets the interpreter result to an error message if the variable is
  1078.  *    unset (NULL).
  1079.  *
  1080.  *----------------------------------------------------------------------
  1081.  */
  1082.  
  1083. static int
  1084. CheckIfVarUnset(interp, varIndex)
  1085.     Tcl_Interp *interp;        /* Interpreter for error reporting. */
  1086.     int varIndex;        /* Index of the test variable to check. */
  1087. {
  1088.     if (varPtr[varIndex] == NULL) {
  1089.     char buf[100];
  1090.     
  1091.     sprintf(buf, "variable %d is unset (NULL)", varIndex);
  1092.     Tcl_ResetResult(interp);
  1093.     Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  1094.     return 1;
  1095.     }
  1096.     return 0;
  1097. }
  1098.